home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 June: Reference Library / Dev.CD Jun 94.toast / Periodicals / develop / develop Issue 5 / develop 5 code / Lisp Mini-App / Program / draw-item-class.lisp < prev    next >
Encoding:
Text File  |  1992-04-08  |  23.7 KB  |  573 lines  |  [TEXT/CCL2]
  1. #|
  2.    draw-item-class.lisp
  3.  
  4.    Defines the DRAW-ITEM class and subclasses used in the Mini-Application
  5.    sample program.
  6.  
  7.    For further info, see files "About Mini-App" and "Instructions".
  8.  
  9.  
  10.    Copyright 1990, 1991 by Ruben Kleiman for Apple Computer, Inc.
  11.  
  12.    Change History.
  13.    03-12-92 slm  Facilitated save-application by delaying getting the
  14.                     handle to tool icons until they are first drawn.
  15.                     Removed open-resource-file from create-draw-item,
  16.                     and added a filename parameter to get-resource-handle
  17.                     in view-draw-contents for icon-draw-items.
  18.                  Methods set-view-position and set-view-size for draw-items
  19.                     were removed because they have no effect beyond 
  20.                     call-next-method!
  21.    03-11-92 slm  Changed all occurrences of defvar to defparameter (1)
  22.                     so that after the Mini-Application is modified, the 
  23.                     changed files can be re-evaluated immediately.
  24.                  Renamed "color-icon" to "icon-draw-item" as it does not
  25.                     have to be color. Replaced its unused "size" slot
  26.                     with an initial value for its view-size.
  27.    03-09-92 slm  Updated file header comments.
  28.    03-08-92 slm  "mini-application;resources" -> "ccl:mini-app;resources"
  29.                  in create-draw-item.
  30.    01-19-92 slm  Added *color-available* test, & #_PlotIcon for B&W systems.
  31.                  class color-icon: increased :size from #@(16 16) to #@(32 32)
  32.    01-17-92 slm  _PtInRect     -> #_PtInRect
  33.                  _framerect    -> #_FrameRect   (2x)
  34.                  _inverrect    -> #_InvertRect  (2x)  ("t" added)
  35.                  _RectRgn      -> #_RectRgn     (2x)
  36.                  _xorrgn#      -> #_XOrRgn
  37.                  _inverRgn     -> #_InvertRgn         ("t" added)
  38.                  _frameoval    -> #_FrameOval
  39.                  _loadresource -> #_LoadResource
  40.                  _plotcicon    -> #_PlotCIcon
  41.                  In addition, most keywords such as :word were removed.
  42.                  :window       -> :windowRecord (2x)
  43.                  (bring-item-to-front (view-container) item) ->
  44.                  (bring-item-to-front (view-container item) item)
  45.  
  46. |#
  47.  
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49. ;;; DRAW-ITEM
  50. ;;;
  51. ;;;    This section defines the behavior of the objects which will be
  52. ;;;    draggable from our palette window onto our draw windows.
  53.  
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;;; DRAW-ITEM Class
  56. ;;;
  57. ;;;   This is the main class of graphical objects which can be either
  58. ;;;   in one of our palettes (instances of the PALETTE class) or 
  59. ;;;   in our windows (instances of the DRAW-DIALOG class)
  60. ;;;
  61. (defclass draw-item (dialog-item)
  62.   ((rectangle :initarg :rectangle :initform nil) ; Rectangle for dragging, resizing, drawing, etc.
  63.    (tool :initarg :tool :initform nil)           ; Is this a item used as a tool?
  64.    (selected :initform nil)                      ; Is this item selected?
  65.    (name :initarg :name :initform ""))           ; The name of this item, if any.
  66.   (:documentation "The user interface objects"))
  67.  
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69. ;;; RESOURCE class
  70. ;;;
  71. ;;;       May be used to compose an item which gets some of
  72. ;;;       its data from a resource.
  73. ;;;
  74. (defclass resource ()
  75.   ((resource-handle :initarg :resource-handle :initform nil)  ; Resource Handle
  76.    (resource-id     :initarg :resource-id     :initform nil)  ; Resource ID
  77.    (resource-type   :initarg :resource-type   :initform nil)) ; Resource type
  78.   )
  79.  
  80. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81. ;;; *slop-in-pixels*
  82. ;;;
  83. ;;;   The amount of slop allowed when resizing a DRAW-ITEM
  84. ;;;
  85. (defparameter *slop-in-pixels* 4)
  86.  
  87. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88. ;;; author-mode-click-handler
  89. ;;;
  90. ;;;   Gets called whenever there is a click in a DRAW-DIALOG window,
  91. ;;;   the click was over a draw item in the window, and
  92. ;;;   the window is in author mode (i.e., not in browse mode)
  93. ;;;
  94. (defmethod author-mode-click-handler ((item draw-item) where)
  95.   (if (double-click-p)
  96.     (author-mode-double-click-handler item where)
  97.     (author-mode-single-click-handler item where)))
  98.  
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100. ;;; author-mode-double-click-handler
  101. ;;;
  102. ;;;   Gets called when there is a double click on the DRAW-DIALOG window,
  103. ;;;   the click was over a draw item in the window, and
  104. ;;;   the window is in author mode
  105. ;;;
  106. (defmethod author-mode-double-click-handler ((item draw-item) where)
  107.   (declare (ignore where))
  108.   ;; Show object information (same as selecting Object Info... menu item)
  109.   (show-object-info item)
  110.   )
  111.  
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113. ;;; author-mode-single-click-handler
  114. ;;;
  115. ;;;   Gets called when there is a double click on the DRAW-DIALOG window,
  116. ;;;   the click was over a draw item in the window, and
  117. ;;;   the window is in author mode
  118. ;;;
  119. (defmethod author-mode-single-click-handler ((item draw-item) mouse-loc)
  120.   (let ((window (view-container item)))
  121.     ;; Check for resize or drag only if mouse moves before it is released:
  122.     (if (loop
  123.           (cond ((not (mouse-down-p))
  124.                  (return nil))
  125.                 ((neq (view-mouse-position window) mouse-loc)
  126.                  (return t))))
  127.       ;; Decide whether we are going to drag or resize it:
  128.       (if (resize? item mouse-loc)
  129.         (resize item mouse-loc)
  130.         (maybe-drag item mouse-loc)))
  131.     ;; Deselect others and select it:
  132.     (deselect-items window)
  133.     (select-item item)))
  134.  
  135. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  136. ;;; select-item
  137. ;;;
  138. ;;;   Called to make item selected.
  139. ;;;
  140. (defmethod select-item ((item draw-item))
  141.   (setf (slot-value item 'selected) t)                ; Set selected flag
  142.   (set-menu-title *selected-object-menu-indicator*    ; Advice menubar
  143.                   (concatenate 'string "Selected:  " (slot-value item 'name)))
  144.   (show-handles item)                                 ; Show object handles
  145.   (pushnew item                                       ; Add item to window's selections list
  146.            (slot-value (view-container item) 'selections)))
  147.  
  148. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  149. ;;; show-handles
  150. ;;;
  151. ;;;   Show selection handles for item. Called whenever
  152. ;;;   the handles must be drawn. This is left as
  153. ;;;   an artistic exercise to the reader!
  154. ;;;
  155. (defmethod show-handles ((item draw-item))
  156.   )
  157.  
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159. ;;; view-draw-contents
  160. ;;;
  161. ;;;   The draw-item will draw its handles if it is selected
  162. ;;;
  163. (defmethod view-draw-contents ((item draw-item))
  164.   (call-next-method)
  165.   (if (slot-value item 'selected)
  166.     (show-handles item)))
  167.  
  168. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  169. ;;; find-draw-dialog-in-point
  170. ;;;
  171. ;;;   This will find the frontmost draw-dialog window where
  172. ;;;   the POINT lies.
  173. ;;;
  174. (defun find-draw-dialog-in-point (point)
  175.   (dolist (window (windows :class 'draw-dialog))
  176.     (and (#_PtInRect :long (subtract-points point (view-position window))
  177.           :ptr (rref (wptr window) :windowRecord.portRect)
  178.           :boolean)
  179.          (return window))))
  180.  
  181. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  182. ;;; move-item-to-window
  183. ;;;
  184. ;;;   Called when we want to move draw-item ITEM from window SOURCE to
  185. ;;;   window DESTINATION.  If SOURCE is a PALETTE, we want to clone the
  186. ;;;   item from the palette; if SOURCE is a window, we are going
  187. ;;;   to move the actual item.  WHERE is the SOURCE-relative coordinate where we want
  188. ;;;   the item to be positioned in the DESTINATION window.
  189. ;;;
  190. (defun move-item-to-window (item where source destination)
  191.   (let* ((global-position (add-points where (view-position source)))
  192.          (local-position 
  193.           (subtract-points global-position (view-position destination))))
  194.     (cond ((and (neq (type-of source) 'PALETTE)
  195.                 (neq (type-of destination) 'PALETTE))
  196.            ;; If neither SOURCE not DESTINATION is a palette, then it is a normal object move
  197.            (remove-subviews source item)
  198.            (add-subviews destination item)
  199.            (set-view-position item local-position)
  200.            (window-select destination))
  201.           (t 
  202.            ;; If SOURCE is a palette, then we are cloning the palette object,
  203.            ;; leaving the original object in the palette (as some might expect)
  204.            (let ((clone (clone-draw-item item)))
  205.              (set-view-position clone local-position)
  206.              (add-items destination clone))))
  207.     (window-select destination)))
  208.  
  209. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  210. ;;; clone-draw-item
  211. ;;;
  212. ;;;   This clones a draw item.  Palette items are cloned from the
  213. ;;;   palettes when they are moved to another window.  The original
  214. ;;;   palette item appears undisturbed in the palette even after the move.
  215. ;;;
  216. (defmethod clone-draw-item ((item draw-item))
  217.   (let ((clone (make-instance (type-of item)
  218.                  :view-position (view-position item)
  219.                  :view-size (view-size item)
  220.                  :name (concatenate 'string
  221.                                     (slot-value item 'name)
  222.                                     (string (gentemp)))))
  223.         (resource-handle (and (slot-exists-p item 'resource-handle)
  224.                               (slot-value item 'resource-handle))))
  225.     ;; Set resource handle, if any (note assumption that resources are shared!):
  226.     (if resource-handle
  227.       (setf (slot-value clone 'resource-handle) resource-handle))
  228.     ;; Set a rectangle:
  229.     (setf (slot-value clone 'rectangle)
  230.           (make-record :rect :topleft 0 :bottomright 0))
  231.     clone))     ; Return clone
  232.  
  233. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  234. ;;; view-center
  235. ;;;
  236. ;;;   This returns the ideal center of a draw-item.
  237. ;;;
  238. (defmethod view-center ((item draw-item))
  239.   (truncate (+ (view-position item)
  240.                (add-points (view-position item)
  241.                            (view-size item)))
  242.             2))
  243.  
  244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  245. ;;; maybe-drag
  246. ;;;
  247. ;;;   Called when the item may have to be dragged.
  248. ;;;   Tools are not draggable.
  249. ;;;
  250. (defmethod maybe-drag ((item draw-item) current-mouse-loc)
  251.   (cond ((slot-value item 'tool)
  252.          (ed-beep)
  253.          (window-select *top-listener*)
  254.          (format t "~%Can't drag ~A out of palette because it's a tool!"
  255.                  (slot-value item 'name)))
  256.         (t (drag item current-mouse-loc))))
  257.  
  258. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  259. ;;; drag
  260. ;;;
  261. ;;;   Called when item must be dragged by user
  262. ;;;
  263. (defmethod drag ((item draw-item) current-mouse-loc)
  264.   (let ((start-position (view-position item))   ; where are we starting the drag from?
  265.         (end-position nil)                      ; where dragged ended (in screen coordinates!)
  266.         (item-region (new-region))              ; a region that defines what we are dragging
  267.         (window (view-container item))          ; the window in which the drag started
  268.         (destination-window nil)                ; the window in which the drag ended
  269.         (drag-offset nil))                      ; what's the offset after the drag?
  270.     (unwind-protect      ; we want to make sure that the item-region is disposed after an error
  271.       (progn        
  272.         ;; Define the region that we want to drag:
  273.         (open-region window)
  274.         (with-port (wptr item)
  275.           (#_FrameRect :ptr (slot-value item 'rectangle))) ;; The rectangle is OK, could ask the item.
  276.         (close-region window item-region)         
  277.         ;; Do the drag and get the offset of the drag:
  278.         (setq drag-offset
  279.               (drag-inverted-region (view-container item) item-region :start current-mouse-loc))       
  280.         ;; Find out in which window the item landed:
  281.         (setq end-position (add-points start-position drag-offset)
  282.               destination-window 
  283.               (find-draw-dialog-in-point (add-points end-position (view-position window))))
  284.         (when destination-window               ; Do nothing if it lands nowhere
  285.           (if (eq window destination-window)
  286.             ;; Move within this window:  set the item's position at the end of the drag:
  287.             (unless (eq (type-of window) 'PALETTE)    ; We don't want anyone to move palette items!
  288.               (set-view-position item end-position))
  289.             ; Move to another window: drop it there
  290.             (move-item-to-window item end-position window destination-window))
  291.           (view-draw-contents item)))
  292.       (dispose-region item-region))))
  293.  
  294. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  295. ;;; show-info
  296. ;;;
  297. ;;;   This gets called whenever a draw item must show its information
  298. ;;;
  299. (defmethod show-info ((item draw-item))
  300.   ;; Displays an information box for a draw-item
  301.   )
  302.  
  303. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  304. ;;; bring-to-front
  305. ;;;
  306. ;;;   Called whenever we want to bring a draw-item to the
  307. ;;;   front of other draw-items in the draw-dialog window.
  308. ;;;   This method simply passes the buck to the window
  309. ;;;   (its container view).
  310. ;;;
  311. (defmethod bring-to-front ((item draw-item))
  312.   (bring-item-to-front (view-container item) item))                              
  313.                               
  314. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  315. ;;; resize?
  316. ;;;
  317. ;;;   Called to ask whether the user intends to resize the item
  318. ;;;   The resize area is assumed to be a frame around but within
  319. ;;;   the object's rectangle, offset by amount of slop.
  320. ;;;
  321. (defmethod resize? ((item draw-item) current-mouse-loc)
  322.   (when (neq (type-of (view-container item)) 'PALETTE)  ; PALETTE items can't be resized
  323.     (rlet ((handles-rect :rect
  324.                          :topleft (view-position item)
  325.                          :bottomright (add-points (view-position item)
  326.                                                   (view-size item))))
  327.       (inset-rect handles-rect *slop-in-pixels* *slop-in-pixels*)
  328.       (not (point-in-rect-p handles-rect current-mouse-loc)))))
  329.  
  330.  
  331. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  332. ;;; resize
  333. ;;;
  334. ;;;   Called when item must be resized by user in some way
  335. ;;;
  336. (defmethod resize ((item draw-item) current-mouse-loc)
  337.   (let* ((resize-direction (get-resize-direction item current-mouse-loc))
  338.          (topleft (view-position item))
  339.          (size (view-size item))
  340.          (bottomright (add-points topleft size))
  341.          (top (point-v topleft))
  342.          (left (point-h topleft))
  343.          (bottom (point-v bottomright))
  344.          (right (point-h bottomright))
  345.          new-mouse-loc new-mouse-h new-mouse-v
  346.          ;; Two regions to produce inverted effect:
  347.          (old-resize-region (new-region))
  348.          (new-resize-region (new-region))
  349.          ;; The rectangle enclosing the window
  350.          (window-rectangle (rref (wptr item) :windowRecord.portrect))
  351.          ;; The rectangle enclosing the draw-item:
  352.          (item-rectangle (slot-value item 'rectangle))
  353.          (window (view-container item)))
  354.     ;(format t "Resizing ~a ~a..." resize-direction item)
  355.     (#_InvertRect :ptr item-rectangle)
  356.     (unwind-protect
  357.       (loop ; until the mouse is released
  358.         (if (not (mouse-down-p))
  359.           (return nil)) ; We're through!
  360.         ;; Update the location of the mouse in window coordinates
  361.         (setq new-mouse-loc (view-mouse-position window)
  362.               new-mouse-h (point-h new-mouse-loc)
  363.               new-mouse-v (point-v new-mouse-loc))
  364.         ;; Do resize graphics if mouse is within the window:
  365.         (when (point-in-rect-p window-rectangle new-mouse-loc)
  366.           (#_RectRgn :ptr old-resize-region
  367.            :ptr item-rectangle)    ; MIGHT BE NEW-RESIZE-REGION
  368.           (case resize-direction
  369.             (:top (and (< new-mouse-v bottom)
  370.                        (rset item-rectangle :rect.top new-mouse-v)))
  371.             (:bottom (and (> new-mouse-v top)
  372.                           (rset item-rectangle :rect.bottom new-mouse-v)))
  373.             (:left (and (< new-mouse-h right)
  374.                         (rset item-rectangle :rect.left new-mouse-h)))
  375.             (:right (and (> new-mouse-h left)
  376.                          (rset item-rectangle :rect.right new-mouse-h)))
  377.             (:topleft (and (< new-mouse-v bottom)
  378.                            (< new-mouse-h right)
  379.                            (rset item-rectangle :rect.topleft new-mouse-loc)))
  380.             (:topright (when (and (< new-mouse-v bottom)
  381.                                   (> new-mouse-h left))
  382.                          (rset item-rectangle :rect.right new-mouse-h)
  383.                          (rset item-rectangle :rect.top new-mouse-v)))
  384.             (:bottomleft (when (and (> new-mouse-v top)
  385.                                     (< new-mouse-h right))
  386.                            (rset item-rectangle :rect.left new-mouse-h)
  387.                            (rset item-rectangle :rect.bottom new-mouse-v)))
  388.             (:bottomright (and (> new-mouse-v top)
  389.                                (> new-mouse-h left)
  390.                                (rset item-rectangle :rect.bottomright new-mouse-loc))))
  391.           (#_RectRgn :ptr new-resize-region :ptr item-rectangle)
  392.           (#_XOrRgn :ptr new-resize-region :ptr old-resize-region
  393.            :ptr old-resize-region)
  394.           (#_InvertRgn :ptr old-resize-region)
  395.           ))
  396.       (#_InvertRect :ptr item-rectangle)
  397.       (set-view-size item (subtract-points (rref item-rectangle :rect.bottomright)
  398.                                            (rref item-rectangle :rect.topleft)))
  399.       (set-view-position item (rref item-rectangle :rect.topleft))
  400.       (dispose-region old-resize-region)
  401.       (dispose-region new-resize-region))))
  402.  
  403. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  404. ;;; get-resize-direction
  405. ;;;
  406. ;;;   Called when someone wants to find out in which direction
  407. ;;;   the user intends to resize the item.  Returns one of
  408. ;;;   these:
  409. ;;;      :topleft -- means resize topleft corner,
  410. ;;;      :bottomleft -- means resize bottomleft corner
  411. ;;;      :topright -- means resize topright corner
  412. ;;;      :bottomright -- means resize bottomright corner
  413. ;;;      :top -- means resize top side
  414. ;;;      :bottom -- means resize bottom side
  415. ;;;      :right -- means resize right side
  416. ;;;      :left -- means resize left side
  417. ;;;
  418. (defmethod get-resize-direction ((item draw-item) current-mouse-loc)
  419.   (let* ((item-topleft (view-position item))
  420.          (item-bottomright (add-points item-topleft
  421.                                        (view-size item)))
  422.          (top (+ (point-v item-topleft) *slop-in-pixels*))
  423.          (left (+ (point-h item-topleft) *slop-in-pixels*))
  424.          (bottom (- (point-v item-bottomright) *slop-in-pixels*))
  425.          (right (- (point-h item-bottomright) *slop-in-pixels*))
  426.          (mouse-h (point-h current-mouse-loc))
  427.          (mouse-v (point-v current-mouse-loc)))
  428.     (cond ((<= mouse-h left)
  429.            (if (<= mouse-v top)
  430.              :topleft
  431.              (if (>= mouse-v bottom)
  432.                :bottomleft
  433.                :left)))
  434.           ((>= mouse-h right)
  435.            (if (<= mouse-v top)
  436.              :topright
  437.              (if (>= mouse-v bottom)
  438.                :bottomright
  439.                :right)))
  440.           ((<= mouse-v top)
  441.            :top)
  442.           (T
  443.            :bottom))))
  444.  
  445.  
  446. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  447. ;;; DRAW-ITEM SUBCLASSES
  448. ;;;
  449.  
  450. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  451. ;;; round-button
  452. ;;;
  453. (defclass round-button (draw-item button-dialog-item)
  454.   ()
  455.   )
  456.  
  457. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  458. ;;; check-box
  459. ;;;
  460. (defclass check-box (draw-item check-box-dialog-item)
  461.   ()
  462.   )
  463.  
  464. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  465. ;;; radio-button
  466. ;;;
  467. (defclass radio-button (draw-item radio-button-dialog-item)
  468.   ()
  469.   )
  470.  
  471. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  472. ;;; text
  473. ;;;
  474. (defclass text (draw-item fred-dialog-item)
  475.   ()
  476.   )
  477.  
  478. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  479. ;;; rectangle
  480. ;;;
  481. (defclass rectangle (draw-item)
  482.   ()
  483.   )
  484. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  485. ;;; view-draw-contents
  486. ;;;
  487. ;;;   Teach rectangle how to draw itself
  488. ;;;
  489. (defmethod view-draw-contents ((rectangle rectangle))
  490.   (with-port (wptr rectangle)
  491.     (#_FrameRect :ptr (slot-value rectangle 'rectangle)))
  492.   (call-next-method))
  493.  
  494. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  495. ;;; oval
  496. ;;;
  497. (defclass oval (draw-item)
  498.   ()
  499.   )
  500.  
  501. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  502. ;;; view-draw-contents
  503. ;;;
  504. ;;;   Teach oval how to draw itself
  505. ;;;
  506. (defmethod view-draw-contents ((oval oval))
  507.   (with-port (wptr oval)
  508.     (#_FrameOval :ptr (slot-value oval 'rectangle)))
  509.   (call-next-method))
  510.  
  511. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  512. ;;; icon-draw-item
  513. ;;;
  514. (defclass icon-draw-item (draw-item resource)
  515.   ()
  516.   (:default-initargs :view-size #@(32 32)))
  517.  
  518. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  519. ;;; view-draw-contents
  520. ;;;
  521. ;;; This draws a icon-draw-item (as a "cicn") into the appropiate rectangle.
  522. ;;; On B&W systems, an ICON (identical to the cicn when viewed in B&W) 
  523. ;;; will be drawn.
  524. ;;;
  525. (defmethod view-draw-contents ((icon icon-draw-item))
  526.   (let* ((resource-file "ccl:mini-app;resources")
  527.          (handle (or (slot-value icon 'resource-handle)
  528.                      (get-resource-handle (slot-value icon 'resource-type) 
  529.                                           (slot-value icon 'resource-id)
  530.                                           resource-file)))
  531.          (rectangle (slot-value icon 'rectangle)))
  532.     (when (handlep handle)
  533.       (#_LoadResource :ptr handle)   ;Must ensure that resource is in memory
  534.       (with-port (wptr icon)
  535.         (if *color-available*
  536.           (#_PlotCIcon rectangle handle)
  537.           (#_PlotIcon  rectangle handle))))
  538.     (call-next-method)))
  539.  
  540. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  541. ;;; create-draw-item
  542. ;;;
  543. ;;;   Creates and returns a DRAW-ITEM of the given class
  544. ;;;
  545. (defun create-draw-item (&key (name "Untitled")
  546.                               (class 'rectangle)
  547.                               (tool nil)
  548.                               (resource-type 
  549.                                (if *color-available* "cicn" "ICON"))
  550.                               (resource-id nil))
  551.   (let ((new-item (make-instance class :name name :tool tool)))
  552.     (when (slot-exists-p new-item 'resource-handle)
  553.       ;; We need resource information to make this object do its thing
  554.       (unless resource-id
  555.         (error "Object ~a needed a resource id to work" new-item))
  556.       (setf (slot-value new-item 'resource-handle) nil)
  557.             ;;Don't get the handle yet; make save-application easier
  558.       (setf (slot-value new-item 'resource-id)   resource-id)
  559.       (setf (slot-value new-item 'resource-type) resource-type))
  560.     new-item))
  561.  
  562. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  563. ;;; create-tool
  564. ;;;
  565. ;;;   Creates and returns a tool of the given class
  566. ;;;
  567. (defun create-tool (&rest init-args)
  568.   (apply #'create-draw-item (nconc init-args (list :tool T))))
  569.  
  570.  
  571. ;end of file draw-item-class.lisp
  572. ;------------------------------------------------
  573.